home *** CD-ROM | disk | FTP | other *** search
/ isnet Internet / Isnet Internet CD.iso / prog / hiz / 09 / 09.exe / adynware.exe / perl / lib / site / LWP / Socket.pm < prev    next >
Encoding:
Perl POD Document  |  1999-12-28  |  8.5 KB  |  393 lines
  1.  
  2. package LWP::Socket;
  3.  
  4. =head1 NAME
  5.  
  6. LWP::Socket - TCP/IP socket interface
  7.  
  8. =head1 SYNOPSIS
  9.  
  10.  $socket = new LWP::Socket;
  11.  $socket->connect('localhost', 7); # echo
  12.  $quote = 'I dunno, I dream in Perl sometimes...';
  13.  $socket->write("$quote\n");
  14.  $socket->read_until("\n", \$buffer);
  15.  $socket->read(\$buffer);
  16.  $socket = undef;  # close
  17.  
  18. =head1 DESCRIPTION
  19.  
  20. This class implements TCP/IP sockets.  It groups socket generation,
  21. TCP address manipulation and buffered reading. Errors are handled by
  22. dying (throws exceptions).
  23.  
  24. This class should really not be required, something like this should
  25. be part of the standard Perl5 library.
  26.  
  27. Running this module standalone executes a self test which requires
  28. localhost to serve chargen and echo protocols.
  29.  
  30. =head1 METHODS
  31.  
  32. =cut
  33.  
  34.  
  35. $VERSION = sprintf("%d.%02d", q$Revision: 1.22 $ =~ /(\d+)\.(\d+)/);
  36. sub Version { $VERSION; }
  37.  
  38. use Socket qw(pack_sockaddr_in unpack_sockaddr_in
  39.           PF_INET SOCK_STREAM INADDR_ANY
  40.           inet_ntoa inet_aton);
  41. Socket->require_version(1.5);
  42.  
  43. use Carp ();
  44. use Symbol qw(gensym);
  45.  
  46. use LWP::Debug ();
  47. use LWP::IO ();
  48.  
  49. my $tcp_proto = (getprotobyname('tcp'))[2];
  50.  
  51.  
  52. =head2 $sock = new LWP::Socket()
  53.  
  54. Constructs a new socket object.
  55.  
  56. =cut
  57.  
  58. sub new
  59. {
  60.     my($class, $socket, $host, $port) = @_;
  61.  
  62.     unless ($socket) {
  63.     $socket = gensym();
  64.     LWP::Debug::debug("Socket $socket");
  65.  
  66.     socket($socket, PF_INET, SOCK_STREAM, $tcp_proto) or
  67.       Carp::croak("socket: $!");
  68.     }
  69.  
  70.     my $self = bless {
  71.     'socket' => $socket,
  72.     'host'   => $host,
  73.     'port'   => $port,
  74.     'buffer' => '',
  75.     'size'   => 4096,
  76.     }, $class;
  77.  
  78.     $self;
  79. }
  80.  
  81. sub DESTROY
  82. {
  83.     my $socket = shift->{'socket'};
  84.     close($socket);
  85. }
  86.  
  87. sub host { shift->{'host'}; }
  88. sub port { shift->{'port'}; }
  89.  
  90.  
  91. =head2 $sock->connect($host, $port)
  92.  
  93. Connect the socket to given host and port.
  94.  
  95. =cut
  96.  
  97. sub connect
  98. {
  99.     my($self, $host, $port) = @_;
  100.     Carp::croak("no host") unless defined $host && length $host;
  101.     Carp::croak("no port") unless defined $port && $port > 0;
  102.  
  103.     LWP::Debug::trace("($host, $port)");
  104.  
  105.     $self->{'host'} = $host;
  106.     $self->{'port'} = $port;
  107.  
  108.     my @addr = $self->_getaddress($host, $port);
  109.     Carp::croak("Can't resolv address for $host")
  110.       unless @addr;
  111.  
  112.     LWP::Debug::debug("Connecting to host '$host' on port '$port'...");
  113.     for (@addr) {
  114.     connect($self->{'socket'}, $_) and return;
  115.     }
  116.     Carp::croak("Could not connect to $host:$port");
  117. }
  118.  
  119.  
  120. =head2 $sock->shutdown()
  121.  
  122. Shuts down the connection.
  123.  
  124. =cut
  125.  
  126. sub shutdown
  127. {
  128.     my($self, $how) = @_;
  129.     $how = 2 unless defined $how;
  130.     shutdown($self->{'socket'}, $how);
  131.     delete $self->{'host'};
  132.     delete $self->{'port'};
  133. }
  134.  
  135.  
  136. =head2 $sock->bind($host, $port)
  137.  
  138. Binds a name to the socket.
  139.  
  140. =cut
  141.  
  142. sub bind
  143. {
  144.     my($self, $host, $port) = @_;
  145.     my $name = $self->_getaddress($host, $port);
  146.     bind($self->{'socket'}, $name);
  147. }
  148.  
  149.  
  150. =head2 $sock->listen($queuesize)
  151.  
  152. Set up listen queue for socket.
  153.  
  154. =cut
  155.  
  156. sub listen
  157. {
  158.     listen(shift->{'socket'}, @_);
  159. }
  160.  
  161.  
  162. =head2 $sock->accept($timeout)
  163.  
  164. Accepts a new connection.  Returns a new LWP::Socket object if successful.
  165. Timeout not implemented yet.
  166.  
  167. =cut
  168.  
  169. sub accept
  170. {
  171.     my $self = shift;
  172.     my $timeout = shift;
  173.     my $ns = gensym();
  174.     my $addr = accept($ns, $self->{'socket'});
  175.     if ($addr) {
  176.     my($port, $addr) = unpack_sockaddr_in($addr);
  177.     return new LWP::Socket $ns, inet_ntoa($addr), $port;
  178.     } else {
  179.     Carp::croak("Can't accept: $!");
  180.     }
  181. }
  182.  
  183.  
  184. =head2 $sock->getsockname()
  185.  
  186. Returns a 2 element array ($host, $port)
  187.  
  188. =cut
  189.  
  190. sub getsockname
  191. {
  192.     my($port, $addr) = unpack_sockaddr_in(getsockname(shift->{'socket'}));
  193.     (inet_ntoa($addr), $port);
  194. }
  195.  
  196.  
  197. =head2 $sock->read_until($delim, $data_ref, $size, $timeout)
  198.  
  199. Reads data from the socket, up to a delimiter specified by a regular
  200. expression.  If $delim is undefined all data is read.  If $size is
  201. defined, data will be read internally in chunks of $size bytes.  This
  202. does not mean that we will return the data when size bytes are read.
  203.  
  204. Note that $delim is discarded from the data returned.
  205.  
  206. =cut
  207.  
  208. sub read_until
  209. {
  210.     my ($self, $delim, $data_ref, $size, $timeout) = @_;
  211.  
  212.     {
  213.     my $d = $delim;
  214.     $d =~ s/\r/\\r/g;
  215.     $d =~ s/\n/\\n/g;
  216.     LWP::Debug::trace("('$d',...)");
  217.     }
  218.  
  219.     my $socket = $self->{'socket'};
  220.     $delim = '' unless defined $delim;
  221.     $size ||= $self->{'size'};
  222.  
  223.     my $buf = \$self->{'buffer'};
  224.  
  225.     if (length $delim) {
  226.     while ($$buf !~ /$delim/) {
  227.         LWP::IO::read($socket, $$buf, $size, length($$buf), $timeout)
  228.         or die "Unexpected EOF";
  229.     }
  230.     ($$data_ref, $self->{'buffer'}) = split(/$delim/, $$buf, 2);
  231.     } else {
  232.     $data_ref = $buf;
  233.     $self->{'buffer'} = '';
  234.     }
  235.  
  236.     1;
  237. }
  238.  
  239.  
  240. =head2 $sock->read($bufref, [$size, $timeout])
  241.  
  242. Reads data of the socket.  Not more than $size bytes.  Might return
  243. less if the data is available.  Dies on timeout.
  244.  
  245. =cut
  246.  
  247. sub read
  248. {
  249.     my($self, $data_ref, $size, $timeout) = @_;
  250.     $size ||= $self->{'size'};
  251.  
  252.     LWP::Debug::trace('(...)');
  253.     if (length $self->{'buffer'}) {
  254.     $$data_ref = substr($self->{'buffer'}, 0, $size);
  255.     substr($self->{'buffer'}, 0, $size) = '';
  256.     return length $$data_ref;
  257.     }
  258.     LWP::IO::read($self->{'socket'}, $$data_ref, $size, undef, $timeout);
  259. }
  260.  
  261.  
  262. =head2 $sock->pushback($data)
  263.  
  264. Put data back into the socket.  Data will returned next time you
  265. read().  Can be used if you find out that you have read too much.
  266.  
  267. =cut
  268.  
  269. sub pushback
  270. {
  271.     LWP::Debug::trace('(' . length($_[1]) . ' bytes)');
  272.     my $self = shift;
  273.     substr($self->{'buffer'}, 0, 0) = shift;
  274. }
  275.  
  276.  
  277. =head2 $sock->write($data, [$timeout])
  278.  
  279. Write data to socket.  The $data argument might be a scalar or code.
  280.  
  281. If data is a reference to a subroutine, then we will call this routine
  282. to obtain the data to be written.  The routine will be called until it
  283. returns undef or empty data.  Data might be returned from the callback
  284. as a scalar or as a reference to a scalar.
  285.  
  286. Write returns the number of bytes written to the socket.
  287.  
  288. =cut
  289.  
  290. sub write
  291. {
  292.     my $self = shift;
  293.     my $timeout = $_[1];  # we don't want to copy data in $_[0]
  294.     LWP::Debug::trace('()');
  295.     my $bytes_written = 0;
  296.     if (!ref $_[0]) {
  297.     $bytes_written = LWP::IO::write($self->{'socket'}, $_[0], $timeout);
  298.     } elsif (ref($_[0]) eq 'CODE') {
  299.     my $callback = shift;
  300.     while (1) {
  301.         my $data = &$callback;
  302.         last unless defined $data;
  303.         my $dataRef = ref($data) ? $data : \$data;
  304.         my $len = length $$dataRef;
  305.         last unless $len;
  306.         my $n = $self->write($$dataRef, $timeout);
  307.         $bytes_written += $n;
  308.         last if $n != $len;
  309.     }
  310.     } else {
  311.     Carp::croak('Illegal LWP::Socket->write() argument');
  312.     }
  313.     $bytes_written;
  314. }
  315.  
  316.  
  317.  
  318. =head2 _getaddress($h, $p)
  319.  
  320. Given a host and a port, it will return the address (sockaddr_in)
  321. suitable as the C<name> argument for connect() or bind(). Might return
  322. several addresses in array context if the hostname is bound to several
  323. IP addresses.
  324.  
  325. =cut
  326.  
  327.  
  328. sub _getaddress
  329. {
  330.     my($self, $host, $port) = @_;
  331.  
  332.     my(@addr);
  333.     if (!defined $host) {
  334.     $addr[0] = pack_sockaddr_in($port, INADDR_ANY);
  335.     }
  336.     elsif ($host =~ /^(\d+\.\d+\.\d+\.\d+)$/) {
  337.     $addr[0] = pack_sockaddr_in($port, inet_aton($1));
  338.     } else {
  339.     LWP::Debug::debug("resolving host '$host'...");
  340.     (undef,undef,undef,undef,@addr) = gethostbyname($host);
  341.     for (@addr) {
  342.         LWP::Debug::debug("   ..." . inet_ntoa($_));
  343.         $_ = pack_sockaddr_in($port, $_);
  344.     }
  345.     }
  346.     wantarray ? @addr : $addr[0];
  347. }
  348.  
  349.  
  350.  
  351. package main;
  352.  
  353. eval join('',<DATA>) || die $@ unless caller();
  354.  
  355. =head1 SELF TEST
  356.  
  357. This self test is only executed when this file is run standalone. It
  358. tests its functions against some standard TCP services implemented by
  359. inetd. If you do not have them around the tests will fail.
  360.  
  361. =cut
  362.  
  363. 1;
  364.  
  365. __END__
  366.  
  367. LWP::Debug::level('+');
  368.  
  369. &chargen;
  370. &echo;
  371. print "Socket.pm $LWP::Socket::VERSION ok\n";
  372.  
  373. sub chargen
  374. {
  375.     my $socket = new LWP::Socket;
  376.     $socket->connect('localhost', 19); # chargen
  377.     $socket->read_until('A', \$buffer, 8);
  378.  
  379.     die 'Read Error' unless $buffer eq ' !"#$%&\'()*+,-./0123456789:;<=>?@';
  380.     $socket->read_until('Z', \$buffer, 8);
  381.     die 'Read Error' unless $buffer eq 'BCDEFGHIJKLMNOPQRSTUVWXY';
  382. }
  383.  
  384. sub echo
  385. {
  386.     $socket = new LWP::Socket;
  387.     $socket->connect('localhost', 7); # echo
  388.     $quote = 'I dunno, I dream in Perl sometimes...';
  389.     $socket->write("$quote\n");
  390.     $socket->read_until("\n", \$buffer);
  391.     die 'Read Error' unless $buffer eq $quote;
  392. }
  393.